home *** CD-ROM | disk | FTP | other *** search
/ BMUG Revelations / BMUG Revelations.toast / Programming / Programming Languages / Yerk 3.64 / System source / Struct < prev    next >
Encoding:
Text File  |  1993-06-09  |  5.4 KB  |  183 lines  |  [TEXT/YERK]
  1. \ Modification  History - This file contains data primitives
  2. \  4/11/84  CBD Version 1.00
  3. \  4/26/84  CBD Added  +TO:  for all indexed objects
  4. \  4/26/84  CBD Optimized  fetches and stores with code
  5. \  4/27/84  CBD Changed Ordered-Col to work right
  6. \  4/28/84  CBD Added  INT: method for Ints
  7. \  5/23/84  NDI OBJECT read & write methods
  8. \  5/25/84  NDI File handling moved from File.scr
  9. \  6/10/84  CBD Moved EVENT class into STRUCT
  10. \  6/10/84  CBD Added CLEAR: method for arrays
  11. \  6/11/84  NDI Swapped stack input for read & write
  12. \  8/08/84  CBD Added default ClassInit: method to Object
  13. \ 10/10/84  CBD Removed Object to Object.scr
  14. \ 10/11/84  CBD Removed File to file.scr
  15. \ 10/12/84  CBD Removed Set:, Dispatch: is now Exec:
  16. \ 10/12/84  CBD Methods no longer pull names from input stream
  17. \ 10/12/84  CBD Ordered-collection is simpler and faster
  18. \ 10/30/84  CBD Moved Var to Object.scr
  19. \ 11/20/84  CBD Ordered-Col is subclass of X-Array; more handle methods
  20. \ 11/22/84  cbd Added wordCol
  21. \ 12/08/84  cbd ß1.0 version
  22. \ 11/04/85  cdn Added $= ; Fixed new: method in Array
  23. \  9/26/86  cdn Added check for 0 handle in release: handleobj
  24. \  3/08/88    rfl    lock: handle does not keep the pointer; added unlock etc
  25. \  7/02/90    rfl    added moveHi to lock (as in IMAC)
  26. \  9/27/90    rfl    added hgetstate and hsetstate to handle
  27. \ 12/13/90    rfl    made locked?: clean as in MOPS
  28. \  2/22/91    rfl    added negate: to int and var
  29. \  4/30/93    rfl added valid: to handle; setsize!: preserves handle state
  30.  
  31. Decimal
  32. ' null cfa value nullCfa
  33.  
  34. \ handy handle primitives
  35. create unlock        ( h --)        $ 205f w, $ a02a w, next,
  36. create hgetstate    ( -- st)    popa0 $ a069 w, pushd0 next,
  37. create hsetstate    ( st h --)    popa0 popd0 $ a06a w, next,
  38. create reserveMem    ( --)        $ 201f w, $ a040 w, next,
  39. create moveHi        ( h --)        popA0 $ a064 w, next,
  40.  
  41. \ =========== Variables =============
  42. :CLASS Int  <Super Object
  43.  
  44.     2 BYTES DATA
  45.  
  46.     :M  CLEAR:    0 MW!            ;M
  47.     :M  GET:    MW@                ;M    \ Fetch
  48.     :M  INT:    MW@  makeInt    ;M    \ Return as toolbox INT
  49.     :M  UGET:    MW@ $ ffff and    ;M    \ get as unsigned
  50.     :M  PUT:    MW!                ;M    \ Store
  51.     :M  +:        COPYM   W+!        ;M    \ add value to a word
  52.     :M  PRINT:    MW@ .            ;M
  53.     :M  =:        MW@ swap W!        ;M    \ addr =:  int
  54.     :M  NEGATE: MW@ negate MW!  ;M
  55.  
  56. ;CLASS
  57.  
  58. \ Define the basic 4-byte variable class
  59. :CLASS Var  <Super Object
  60.  
  61.     4 BYTES Data
  62.  
  63.     :M  CLEAR:    0 M! ;M
  64.     :M  GET:    M@   ;M
  65.  
  66.     \ ( -- ^obj ) get contents as an object  pointer
  67.     :M  OBJ:    M@ dup 0= classErr" 157  ;M    \ invalid obj addr
  68.     :M  PUT:    M!           ;M
  69.     :M  +:        COPYM   +!   ;M
  70.     :M  PRINT:    M@ .  ;M
  71.     :M  DISPOSE:  copym dispose  ;M    \ dispose of heap ptr
  72.     :M  EXEC:    M@ dup 0= classErr" 131 execute ;M
  73.     :M  =:        M@ swap !  ;M    \ r to l assignment to address
  74.     :M  NEGATE: M@ negate M! ;M
  75.  
  76. ;CLASS
  77.  
  78. \ Handle class can store handles to relocatable heap blocks.
  79. :CLASS Handle  <Super Var
  80.  
  81.     :M  VALID: ( -- b) m@ ?ishandle ;M
  82.  
  83.     :M  LOCKED?: ( -- b)   m@ hGetState $ 80 and ;M
  84.     :M  GETSTATE: ( -- st) m@ hGetState ;M
  85.     :M  SETSTATE: ( st --) m@ hSetState ;M
  86.  
  87.     :M  LOCK:  m@ moveHi m@  lock  drop  ;M    \ lock the heap and don't keep rel. ptr
  88.     :M  UNLOCK: m@ unlock ;M
  89.  
  90.     :M  PTR:  m@  >ptr  ;M    \ return relative pointer from handle
  91.     :M  RELEASE:  m@ -dup IF killHandle 0 m! THEN   ;M    \ dispose of heap
  92.  
  93.     \ ( size -- )  set new size for handle
  94.     :M  SETSIZE:  m@ swap setHSize ?error 166  ;M    \ SetHandleSize failed
  95.  
  96.     \ ( size -- )  set new size for handle - If handle is locked, still works
  97.     :M  SETSIZE!:  m@ hGetState  m@ rot m@ unlock setHSize swap m@ hSetState
  98.         ?error 166  ;M    \ SetHandleSize failed
  99.  
  100.     \ ( -- size )  return current size
  101.     :M  SIZE:  get: self  getHSize   ;M
  102.  
  103.     \ ( len -- )  obtain handle to Len bytes of heap and store it in data
  104.     :M  NEW:  newHandle  m!  ;M
  105.  
  106.     :M  MOVEHI: m@ moveHi ;M
  107.     \ ( -- tf)
  108.  
  109. ;CLASS
  110.  
  111. \ ============= Arrays =============
  112.  
  113. \ Basic 4-byte cell array
  114. :CLASS Array  <Super Object  4 <Indexed
  115. \ uses basic methods defined in Object
  116.  
  117.     \ ( ind -- )  return relative pointer from handle
  118.     :M  PTR:  AT4  >ptr  ;M
  119.  
  120.     \ ( ind -- )  dispose of non-relocatable heap
  121.     :M  DISPOSE: ^elem dispose   ;M
  122.  
  123.     \ ( ind -- )   dispose of relocatable heap
  124.     :M  RELEASE:  dup at: self  killHandle
  125.         0 swap to: self    ;M
  126.  
  127.     \ ( ind len -- )  obtain ptr to Len bytes of heap and store it in data
  128.     :M  NEW:  newPtr swap TO4  ;M
  129.  
  130. ;CLASS
  131.  
  132. \ x-Array can execute its elements
  133. :CLASS X-Array  <Super Array
  134.  
  135.     \ ( ind -- )  execute the cfa at Ind
  136.     :M  EXEC:  AT: SELF dup 0=
  137.         classErr" 131 EXECUTE   ;M
  138.  
  139.     :M  CLASSINIT:  limit  0
  140.         DO  nullCfa i To: self  LOOP  ;M
  141.  
  142. ;CLASS
  143.  
  144. \ =========== Lists ===========
  145. \ Ordered-Collection is an ordered list with current size
  146. :CLASS Ordered-Col  <Super X-Array  4 <Indexed
  147.  
  148.     Int        Size    \ # elements in list
  149.  
  150.     \ ( -- curSize )  Return #elements currently in list
  151.     :M  SIZE:  Get: Size  ;M
  152.  
  153.     \ ( -- )  set to null list
  154.     :M  CLEAR:  Clear: Size   Clear: Super  ;M
  155.  
  156.     \ ( val -- )  Add value to end of list
  157.     :M  ADD:  Get: Size  limit  >=
  158.         classErr" 137  Get: size  To: Self
  159.         1 +: Size   ;M
  160.  
  161.     \ ( -- ^file )  return contents of end of list
  162.     :M  LAST:  get: size  dup 0= classerr" 136
  163.         1- at: self    ;M
  164.  
  165.     \ ( ind -- )  remove the element at index
  166.     :M  REMOVE: { ind -- }  ind   Get: size >=
  167.         classErr" 136 Get: size 1- ind
  168.         DO  I 1+ at: self  I to: self LOOP  -1 +: size  ;M
  169.  
  170.     \ ( val -- ind t OR f)  Find a value in an OC
  171.     :M  INDEXOF:  0 swap Get: Size  0
  172.         DO I  at4
  173.             over = IF 2drop  I 1 1 leave THEN
  174.         LOOP  drop  ;M
  175.  
  176. ;CLASS
  177.  
  178. : $= { addr1 len1 addr2 len2 -- }
  179.     word0 addr1 +base addr2 +base len1 len2 pack w 10
  180.     $ a9ed Trap i->l ;
  181.  
  182. <" BasicStr
  183.